home *** CD-ROM | disk | FTP | other *** search
/ BCI NET 2 / BCI NET 2.iso / archives / programming / e / amigae30a_fr.lha / AmigaE30f / Sources / Lang / Yax / Yax11.e < prev   
Encoding:
Text File  |  1994-02-21  |  18.7 KB  |  631 lines
  1. /* Interpréteur YAX (Yet Another Instruction Code Set) v1.0
  2.    Langage procédural/fonctionnel simple avec une syntaxe proche du lisp.
  3.    Dévore de préférence les sources avec extension .yax au dîner.
  4.    Traduction : Olivier ANH (BUGSS)
  5. */
  6.  
  7.  
  8. OPT STACK=25000     /* il y aura de grosse récursions */
  9.  
  10. OBJECT var          /* c'est là que l'on stocke les valeurs runtime */
  11.   type:INT
  12.   name:LONG
  13.   value:LONG
  14. ENDOBJECT
  15.  
  16. /* codes intermediaires */
  17. ENUM ENDSOURCE,VALUE,ISTRING,IDENT,LBRACKET,RBRACKET
  18.  
  19. /* mots clefs */
  20. ENUM FWRITE=100,FADD,FEQ,FUNEQ,FSUB,FMUL,FDIV,FAND,FORX,FNOT,FIF,FDO,
  21.      FSELECT,FSET,FFOR,FWHILE,FUNTIL,FDEFUN,FLAMBDA,FAPPLY,FREADINT,
  22.      FARRAY,FGREATER,FSMALLER,FLOCATE,FCLS,FDUMP,FWINDOW,FTELL,FTOLD,
  23.      FSEE,FSEEN,FSTRING,FREAD,FGET,FPUT,FFILELEN,FLINE,FPLOT,FBOX,
  24.      FMOUSEX,FMOUSEY,FMOUSE,FTEXT,LAST
  25.  
  26. CONST KEYWORDSIZE=8,
  27.       NRKEYWORDS=LAST-99,
  28.       IDENTNAMESPACE=30000,
  29.       VARSTACKSPACE=50000,
  30.       MAXARGS=5,
  31.       ERLEN=60
  32.  
  33. /* erreurs */
  34. ENUM ER_WORKSPACE=1,ER_BUF,ER_GARBAGE,ER_SYNTAX,ER_EXPKEYWORD,ER_EXPRBRACKET,
  35.      ER_EXPEXP,ER_QUOTE,ER_COMMENT,ER_INFILE,ER_SOURCEMEM,ER_EXPIDENT,
  36.      ER_ARGS,ER_TYPE,ER_EXPLBRACKET,ER_STACK,ER_ALLOC,ER_ARRAY,ER_FILE,
  37.      ER_GFXWIN,ER_VALUES
  38.  
  39. /* types de variables */
  40. ENUM TINTEGER=1,TSTRING,TFUNC,TARRAY
  41.  
  42. DEF source,slen,erpos=NIL,
  43.     ilen,ibuf,ipos:PTR TO INT,p:PTR TO INT,idents,
  44.     name[100]:STRING,wfile,
  45.     inputbuf[100]:STRING,winspec[100]:STRING,
  46.     vartop,varbottom,vars,rec,globvar,
  47.     infile,outfile,oldout,oldin,stdin,gfxwindow=0
  48.  
  49. PROC main()
  50.   WriteF(''); stdin:=stdout
  51.   loadsource()
  52.   ilen:=Mul(slen,4)+1000       /* a besoin de l'espace nécessaire */
  53.   ibuf:=New(ilen+10)
  54.   idents:=String(IDENTNAMESPACE)
  55.   vars:=New(VARSTACKSPACE)
  56.   vartop:=vars; varbottom:=vars
  57.   IF (ibuf=NIL) OR (idents=NIL) OR (vars=NIL)
  58.     error(ER_WORKSPACE)
  59.   ELSE
  60.     lexanalyse()               /* traduit au format intermédiaire */
  61.     p:=ibuf
  62.     WHILE p[]<>ENDSOURCE DO eval()       /* lance le code */
  63.   ENDIF
  64.   error(0)
  65. ENDPROC
  66.  
  67. PROC lexanalyse()
  68.   DEF pos,end,c,count,ident[50]:STRING,pos2,keypos,a,nr,ident2[50]:STRING
  69.   pos:=source; end:=pos+slen; ipos:=ibuf; erpos:=pos
  70.   StrCopy(idents,' ',1)
  71.   loop:
  72.   c:=pos[]++
  73.   IF c>96                          /* un identificateur */
  74.     pos2:=pos-1
  75.     WHILE pos[]++>96 DO NOP; DEC pos
  76.     StrCopy(ident,pos2,pos-pos2)
  77.     StrCopy(ident2,ident,ALL)
  78.     StrAdd(ident,'..............',ALL)
  79.     keypos:={keywords}
  80.     nr:=0
  81.     FOR a:=1 TO NRKEYWORDS         /* cherche le mot clef */
  82.       IF StrCmp(ident,keypos,KEYWORDSIZE)
  83.         nr:=99+a
  84.         JUMP found
  85.       ENDIF
  86.       keypos:=keypos+KEYWORDSIZE
  87.     ENDFOR
  88.     found:
  89.     IF nr>0                        /* mot clef */
  90.       iword(nr)
  91.     ELSE                           /* propre identificateur */
  92.       iword(IDENT)
  93.       StrCopy(ident,' ',1)
  94.       StrAdd(ident,ident2,ALL)
  95.       StrAdd(ident,' ',1)
  96.       pos2:=InStr(idents,ident,0)
  97.       IF pos2=-1
  98.         ilong(EstrLen(idents)+idents)
  99.         StrAdd(idents,ident2,ALL)
  100.         StrAdd(idents,' ',1)
  101.         IF EstrLen(idents)=StrMax(idents) THEN error(ER_WORKSPACE)
  102.       ELSE
  103.         ilong(pos2+idents+1)
  104.       ENDIF
  105.     ENDIF
  106.   ELSE
  107.     SELECT c                       /* autre chose */
  108.       CASE " "
  109.         IF pos<end THEN JUMP loop
  110.       CASE "("
  111.         iword(LBRACKET)
  112.         erpos:=pos-1
  113.         ilong(erpos)
  114.       CASE ")"; iword(RBRACKET)
  115.       CASE "+"; iword(FADD)
  116.       CASE "-"
  117.         IF pos[]=" "
  118.           iword(FSUB)
  119.         ELSE
  120.           iword(VALUE)
  121.           ilong(-Val(pos,{c}))
  122.           IF c=0 THEN error(ER_GARBAGE) ELSE pos:=pos+c
  123.         ENDIF
  124.       CASE "*"; iword(FMUL)
  125.       CASE "/"
  126.         IF pos[]<>"*"
  127.           iword(FDIV)
  128.         ELSE                       /* commentaire (comme celui-ci) */
  129.           INC pos
  130.           WHILE pos-1<end
  131.             INC count
  132.             IF (pos[]++="*") AND (pos[]="/") THEN JUMP out
  133.           ENDWHILE
  134.           error(ER_COMMENT)
  135.           out:
  136.           INC pos
  137.         ENDIF
  138.       CASE "="
  139.         iword(FEQ)
  140.       CASE "?"
  141.         iword(FUNEQ)
  142.       CASE "'"                     /* constante  de chaine de caractères */
  143.         iword(ISTRING)
  144.         count:=0; pos2:=pos
  145.         WHILE pos[]++<>"'"
  146.           INC count
  147.           IF pos=end THEN error(ER_QUOTE)
  148.         ENDWHILE
  149.         iword(count)
  150.         ilong(pos2)                /* adresse caractère */
  151.       CASE 10
  152.         IF pos<end THEN JUMP loop
  153.       CASE 0
  154.         pos:=end
  155.       CASE 9
  156.         IF pos<end THEN JUMP loop
  157.       DEFAULT
  158.         iword(VALUE)
  159.         ilong(Val(pos--,{c}))
  160.         IF c=0 THEN error(ER_GARBAGE) ELSE pos:=pos+c
  161.     ENDSELECT
  162.   ENDIF
  163.   IF pos<end THEN JUMP loop
  164.   iword(ENDSOURCE)
  165. ENDPROC
  166.  
  167. PROC checkstop()
  168.   IF FreeStack()<1000 THEN error(ER_STACK)
  169.   IF CtrlC() THEN error(-1)
  170. ENDPROC
  171.  
  172. PROC eval()                        /* fonction principale d'évaluation de la récursion */
  173.   DEF r=0,i,ins,p2,x:PTR TO LONG,a,adr:PTR TO var
  174.   checkstop()
  175.   i:=p[]++
  176.   SELECT i
  177.     CASE VALUE
  178.       r:=^p++
  179.     CASE IDENT
  180.       r:=varvalue(^p++,TINTEGER)
  181.     CASE LBRACKET
  182.       erpos:=^p++
  183.       ins:=p[]++
  184.       IF ins=IDENT
  185.         adr:=findvar(^p++)
  186.         IF adr.type=TFUNC
  187.           r:=dofunc(adr.value)
  188.         ELSE
  189.           IF adr.type<>TARRAY THEN error(ER_TYPE)
  190.           x:=adr.value
  191.           a:=eval()
  192.           IF (a<0) OR (a>x[]) THEN error(ER_ARRAY)
  193.           r:=x[a+1]
  194.         ENDIF
  195.       ELSE
  196.         IF ins<100 THEN error(ER_EXPKEYWORD)
  197.         SELECT ins
  198.           CASE FWRITE                /* sortie de la constante chaine + expressions */
  199.             x:=TRUE
  200.             WHILE p[]<>RBRACKET
  201.               IF p[]=ISTRING
  202.                 Write(stdout,Long(p+4),p[1])
  203.                 IF (p[1]=0) AND (p[4]=RBRACKET) THEN x:=FALSE
  204.                 p:=p+8
  205.               ELSEIF p[]=IDENT
  206.                 IF (Int(findvar(Long(p+2)))=TSTRING)
  207.                   WriteF('\s',eatstring())
  208.                 ELSE
  209.                   WriteF('\d',eval())
  210.                 ENDIF
  211.               ELSE
  212.                 WriteF('\d',eval())
  213.               ENDIF
  214.             ENDWHILE
  215.             IF x THEN WriteF('\n')
  216.           CASE FEQ
  217.             r:=TRUE
  218.             x:=eval()
  219.             WHILE p[]<>RBRACKET DO IF x<>eval() THEN r:=FALSE
  220.           CASE FUNEQ; r:=eval()<>eval()
  221.           CASE FGREATER; r:=eval()>eval()
  222.           CASE FSMALLER; r:=eval()<eval()
  223.           CASE FADD; r:=eval(); WHILE p[]<>RBRACKET DO r:=r+eval()
  224.           CASE FSUB; r:=eval(); WHILE p[]<>RBRACKET DO r:=r-eval()
  225.           CASE FMUL; r:=eval(); WHILE p[]<>RBRACKET DO r:=Mul(r,eval())
  226.           CASE FDIV; r:=eval(); WHILE p[]<>RBRACKET DO r:=Div(r,eval())
  227.           CASE FAND; r:=eval(); WHILE p[]<>RBRACKET DO r:=r AND eval()
  228.           CASE FORX; r:=eval(); WHILE p[]<>RBRACKET DO r:=r OR eval()
  229.           CASE FNOT; r:=Not(eval())
  230.           CASE FIF
  231.             IF eval()
  232.               r:=eval()
  233.               IF p[]<>RBRACKET THEN skip()
  234.             ELSE
  235.               skip()
  236.               IF p[]<>RBRACKET THEN r:=eval()
  237.             ENDIF
  238.           CASE FDO; WHILE p[]<>RBRACKET DO r:=eval()
  239.           CASE FSELECT
  240.             x:=eval()
  241.             WHILE p[]<>RBRACKET DO IF x=eval() THEN r:=eval() ELSE skip()
  242.           CASE FSET
  243.             IF p[]=LBRACKET
  244.               p:=p+2
  245.               erpos:=^p++
  246.               x:=varvalue(eatident(),TARRAY)
  247.               a:=eval()
  248.               IF (a<0) OR (a>x[0]) THEN error(ER_ARRAY)
  249.               IF p[]++<>RBRACKET THEN error(ER_EXPRBRACKET)
  250.               x[a+1]:=eval()
  251.             ELSE
  252.               x:=eatident()
  253.               IF (p[]=LBRACKET) AND (p[3]=FLAMBDA)
  254.                 p:=p+8
  255.                 adr:=findvar(x)
  256.                 letvar(adr,p,TFUNC)
  257.                 WHILE p[]<>RBRACKET DO skip()
  258.                 p:=p+2
  259.               ELSE
  260.                 r:=eval()
  261.                 x:=findvar(x)
  262.                 letvar(x,r,TINTEGER)
  263.               ENDIF
  264.             ENDIF
  265.           CASE FFOR
  266.             x:=eatident()
  267.             r:=eval()
  268.             adr:=findvar(x)
  269.             x:=eval()
  270.             p2:=p
  271.             IF r>x               /* descend */
  272.               FOR a:=r TO x STEP -1
  273.                 p:=p2
  274.                 letvar(adr,a,TINTEGER)
  275.                 WHILE p[]<>RBRACKET DO eval()
  276.               ENDFOR
  277.             ELSE
  278.               FOR a:=r TO x
  279.                 p:=p2
  280.                 letvar(adr,a,TINTEGER)
  281.                 WHILE p[]<>RBRACKET DO eval()
  282.               ENDFOR
  283.             ENDIF
  284.             r:=0
  285.           CASE FWHILE
  286.             p2:=p
  287.             WHILE eval()
  288.               WHILE p[]<>RBRACKET DO eval()
  289.               p:=p2
  290.             ENDWHILE
  291.             WHILE p[]<>RBRACKET DO skip()
  292.             r:=0
  293.           CASE FUNTIL
  294.             p2:=p
  295.             WHILE eval()=FALSE
  296.               WHILE p[]<>RBRACKET DO eval()
  297.               p:=p2
  298.             ENDWHILE
  299.             WHILE p[]<>RBRACKET DO skip()
  300.             r:=0
  301.           CASE FDEFUN
  302.             x:=eatident()
  303.             adr:=findvar(x)
  304.             letvar(adr,p,TFUNC)
  305.             WHILE p[]<>RBRACKET DO skip()
  306.           CASE FLAMBDA; error(ER_SYNTAX)
  307.           CASE FAPPLY
  308.             IF p[]<>IDENT
  309.               IF (p[]<>LBRACKET) OR (p[3]<>FLAMBDA) THEN error(ER_EXPIDENT)
  310.               p:=p+8; adr:=p
  311.               WHILE p[]<>RBRACKET DO skip()
  312.               p:=p+2
  313.               r:=dofunc(adr)
  314.             ELSE
  315.               p:=p+2
  316.               r:=dofunc(varvalue(^p++,TFUNC))
  317.             ENDIF
  318.           CASE FREADINT
  319.             IF ReadStr(stdin,inputbuf)=-1
  320.               r:=0
  321.             ELSE
  322.               r:=Val(inputbuf,{x})
  323.             ENDIF
  324.           CASE FARRAY
  325.             adr:=findvar(eatident())
  326.             a:=eval()
  327.             x:=New(Mul(a,4)+8)
  328.             IF x=NIL THEN error(ER_ALLOC)
  329.             letvar(adr,x,TARRAY)
  330.             x[0]:=a
  331.           CASE FLOCATE; WriteF('\e[\d;\dH',eval(),eval())
  332.           CASE FCLS; Out(stdout,12)
  333.           CASE FDUMP
  334.             adr:=varbottom
  335.             WriteF('\n')
  336.             WHILE adr<vartop
  337.               a:=adr.name
  338.               x:=a
  339.               WHILE Char(x)<>" " DO INC x
  340.               Write(stdout,a,x-a)
  341.               x:=adr.type
  342.               SELECT x
  343.                 CASE TINTEGER; WriteF(' = \d (int)\n',adr.value)
  344.                 CASE TSTRING;  WriteF(' = "\s" (string)\n',adr.value)
  345.                 CASE TFUNC;    WriteF(' (function)\n')
  346.                 CASE TARRAY;   WriteF('[\d] (array)\n',Long(adr.value))
  347.               ENDSELECT
  348.               adr:=adr+SIZEOF var
  349.             ENDWHILE
  350.             WriteF('\n')
  351.           CASE FWINDOW
  352.             StringF(winspec,'CON:\d/\d/\d/\d/',eval(),eval(),eval(),eval())
  353.             x:=eatstring()
  354.             StrAdd(winspec,x,ALL)
  355.             wfile:=Open(winspec,1006)
  356.             IF wfile=NIL THEN error(ER_FILE)
  357.             IF conout<>NIL THEN Close(conout)
  358.             stdout:=wfile
  359.             conout:=stdout
  360.             stdin:=stdout
  361.             adr:=OpenWorkBench()
  362.             Forbid()
  363.             a:=NIL
  364.             IF adr<>NIL
  365.               adr:=Long(adr+4)
  366.               WHILE (adr<>NIL) AND (a=NIL)
  367.                 IF StrCmp(x,Long(adr+32),ALL) THEN a:=adr
  368.                 adr:=^adr
  369.               ENDWHILE
  370.             ENDIF
  371.             Permit()
  372.             IF a THEN gfxwindow:=a
  373.           CASE FTELL
  374.             IF outfile<>NIL THEN Close(outfile)
  375.             outfile:=NIL
  376.             outfile:=Open(eatstring(),1006)
  377.             IF outfile=NIL THEN error(ER_FILE)
  378.             oldout:=stdout
  379.             stdout:=outfile
  380.           CASE FTOLD
  381.             IF outfile<>NIL THEN Close(outfile)
  382.             outfile:=NIL
  383.             stdout:=oldout
  384.           CASE FSEE
  385.             IF infile<>NIL THEN Close(infile)
  386.             infile:=NIL
  387.             infile:=Open(eatstring(),1005)
  388.             IF infile=NIL THEN error(ER_FILE)
  389.             oldin:=stdin
  390.             stdin:=infile
  391.           CASE FSEEN
  392.             IF infile<>NIL THEN Close(infile)
  393.             infile:=NIL
  394.             stdin:=oldin
  395.           CASE FSTRING
  396.             adr:=String(250)
  397.             IF adr=NIL THEN error(ER_ALLOC)
  398.             letvar(findvar(eatident()),adr,TSTRING)
  399.           CASE FREAD
  400.             x:=varvalue(eatident(),TSTRING)
  401.             r:=ReadStr(stdin,x)
  402.           CASE FGET; r:=Inp(stdin)
  403.           CASE FPUT; r:=eval(); IF r<>-1 THEN Out(stdout,r)
  404.           CASE FFILELEN
  405.             r:=FileLength(eatstring())
  406.             IF r=-1 THEN r:=0
  407.           CASE FLINE; getrast(); Line(eval(),eval(),eval(),eval(),eval())
  408.           CASE FPLOT; getrast(); Plot(eval(),eval(),eval())
  409.           CASE FBOX
  410.             getrast()
  411.             a:=eval(); x:=eval(); p2:=eval(); r:=eval()
  412.             IF (a>p2) OR (x>r) THEN error(ER_VALUES)
  413.             Box(a,x,p2,r,eval())
  414.             r:=0
  415.           CASE FMOUSEX; r:=MouseX(getwin())
  416.           CASE FMOUSEY; r:=MouseY(getwin())
  417.           CASE FMOUSE; r:=Mouse()
  418.           CASE FTEXT
  419.             adr:=getrast()
  420.             a:=eval(); x:=eval()
  421.             Colour(eval(),eval())
  422.             TextF(a,x,eatstring())
  423.         ENDSELECT
  424.       ENDIF
  425.       IF p[]++<>RBRACKET THEN error(ER_EXPRBRACKET)
  426.     DEFAULT
  427.       IF (i=RBRACKET) OR (i=ISTRING) THEN error(ER_EXPEXP) ELSE error(ER_SYNTAX)
  428.   ENDSELECT
  429. ENDPROC r
  430.  
  431. PROC getwin()
  432.   IF gfxwindow=NIL THEN error(ER_GFXWIN)
  433. ENDPROC gfxwindow
  434.  
  435. PROC getrast()
  436.   DEF r
  437.   IF gfxwindow=NIL THEN error(ER_GFXWIN)
  438.   r:=Long(gfxwindow+50)
  439.   SetStdRast(r)
  440. ENDPROC r
  441.  
  442. PROC eatstring()
  443.   DEF adr,x
  444.   IF p[]=ISTRING
  445.     p:=p+2; x:=p[]++; adr:=^p++
  446.     adr[x]:=0
  447.   ELSE
  448.     adr:=varvalue(eatident(),TSTRING)
  449.   ENDIF
  450. ENDPROC adr
  451.  
  452. PROC eatident()
  453.   IF p[]++<>IDENT THEN error(ER_EXPIDENT)
  454. ENDPROC ^p++
  455.  
  456. PROC dofunc(lcode)
  457.   DEF args[MAXARGS]:ARRAY OF LONG,a=0,oldvarb,oldvart,oldp,x,r=0,olderpos
  458.   checkstop()
  459.   WHILE p[]<>RBRACKET
  460.     IF a=MAXARGS THEN error(ER_ARGS)
  461.     args[a]:=eval()
  462.     INC a
  463.   ENDWHILE
  464.   IF rec=0 THEN globvar:=vartop
  465.   oldvarb:=varbottom; varbottom:=vartop; oldvart:=vartop;
  466.   oldp:=p; p:=lcode; olderpos:=erpos; INC rec
  467.   IF p[]++<>LBRACKET THEN error(ER_EXPLBRACKET)
  468.   erpos:=^p++
  469.   WHILE p[]<>RBRACKET
  470.     IF a=0 THEN error(ER_ARGS)
  471.     x:=findvar(eatident())
  472.     letvar(x,args[]++,TINTEGER)
  473.     DEC a
  474.   ENDWHILE
  475.   IF a<>0 THEN error(ER_ARGS)
  476.   p:=p+2
  477.   WHILE p[]<>RBRACKET DO r:=eval()
  478.   varbottom:=oldvarb; vartop:=oldvart; p:=oldp; erpos:=olderpos; DEC rec
  479. ENDPROC r
  480.  
  481. PROC findvar(id)
  482.   DEF loc=0:PTR TO var,a:PTR TO var
  483.   IF vartop<>varbottom
  484.     a:=varbottom                     /* vérifie les variables locales */
  485.     WHILE (a<vartop) AND (loc=0)
  486.       IF a.name=id THEN loc:=a
  487.       a:=a+SIZEOF var
  488.     ENDWHILE
  489.   ENDIF
  490.   IF loc=0
  491.     IF (rec>0) AND (globvar>vars)    /* vérifie les variables globales */
  492.       a:=vars
  493.       WHILE (a<globvar) AND (loc=0)
  494.         IF a.name=id THEN loc:=a
  495.         a:=a+SIZEOF var
  496.       ENDWHILE
  497.     ENDIF
  498.     IF loc=0                         /* crée de nouvelle variable dynamique */
  499.       loc:=vartop
  500.       vartop:=vartop+SIZEOF var
  501.       IF vars+VARSTACKSPACE<vartop THEN error(ER_WORKSPACE)
  502.       loc.type:=TINTEGER
  503.       loc.name:=id
  504.       loc.value:=0
  505.     ENDIF
  506.   ENDIF
  507. ENDPROC loc
  508.  
  509. PROC letvar(adr:PTR TO var,value,type)
  510.   IF (adr.type<>type) AND (adr.type<>TINTEGER) THEN error(ER_TYPE)
  511.   checkstop()
  512.   adr.type:=type
  513.   adr.value:=value
  514. ENDPROC
  515.  
  516. PROC varvalue(id,type)
  517.   DEF adr:PTR TO var
  518.   checkstop()
  519.   adr:=findvar(id)
  520.   IF adr.type<>type THEN error(ER_TYPE)
  521. ENDPROC adr.value
  522.  
  523. PROC skip()                        /* saute *une* expression */
  524.   DEF deep=0,i
  525.   REPEAT
  526.     i:=p[]++
  527.     IF (i=VALUE) OR (i=LBRACKET) OR (i=IDENT) THEN p:=p+4
  528.     IF i=ISTRING THEN p:=p+6
  529.     IF i=LBRACKET THEN INC deep
  530.     IF i=RBRACKET THEN IF deep=0 THEN error(ER_EXPEXP) ELSE DEC deep
  531.     IF i=ENDSOURCE THEN error(ER_EXPRBRACKET)
  532.   UNTIL deep=0
  533. ENDPROC
  534.  
  535. PROC iword(x)
  536.   IF ibuf+ilen>ipos THEN ipos[]++:=x ELSE error(ER_BUF)
  537. ENDPROC
  538.  
  539. PROC ilong(x)
  540.   IF ibuf+ilen>ipos THEN ^ipos++:=x ELSE error(ER_BUF)
  541. ENDPROC
  542.  
  543. PROC loadsource()
  544.   DEF suxxes=FALSE,handle,read
  545.   IF StrCmp(arg,'?',ALL) OR StrCmp(arg,'',ALL)
  546.     WriteF('USAGE: Yax <source> (extensio par défaut ".yax")\n')
  547.     error(0)
  548.   ELSE
  549.     StrCopy(name,arg,ALL)
  550.     StrAdd(name,'.yax',4)
  551.     slen:=FileLength(name)
  552.     handle:=Open(name,1005)
  553.     IF (handle=NIL) OR (slen=-1)
  554.       error(ER_INFILE)
  555.     ELSE
  556.       source:=New(slen+10)
  557.       IF source=NIL
  558.         error(ER_SOURCEMEM)
  559.       ELSE
  560.         read:=Read(handle,source,slen)
  561.         Close(handle)
  562.         IF read=slen
  563.           suxxes:=TRUE
  564.           source[slen]:=0
  565.         ELSE
  566.           error(ER_INFILE)
  567.         ENDIF
  568.       ENDIF
  569.     ENDIF
  570.   ENDIF
  571. ENDPROC
  572.  
  573. PROC error(nr)
  574.   DEF erstr[ERLEN]:STRING,a
  575.   IF outfile<>NIL
  576.     IF stdout=outfile THEN stdout:=oldout
  577.     Close(outfile)
  578.   ENDIF
  579.   IF infile<>NIL
  580.     IF stdin=infile THEN stdin:=oldin
  581.     Close(infile)
  582.   ENDIF
  583.   WriteF('\n')
  584.   IF nr>0
  585.     WriteF('ERROR: ')
  586.     SELECT nr
  587.       CASE ER_WORKSPACE;   WriteF('Ne peut allouer de la mémoire pour l\aespace de travaille !\n')
  588.       CASE ER_BUF;         WriteF('Dépacement mémoire des buffers !\n')
  589.       CASE ER_GARBAGE;     WriteF('Poubelle en ligne \n')
  590.       CASE ER_SYNTAX;      WriteF('Votre syntaxe pose problême\n')
  591.       CASE ER_EXPKEYWORD;  WriteF('Manque un mot clef\n')
  592.       CASE ER_EXPRBRACKET; WriteF('Manque un crochet droit ]\n')
  593.       CASE ER_EXPEXP;      WriteF('Manque une expression évaluable\n')
  594.       CASE ER_QUOTE;       WriteF('Manque l''apostrophe\a\n')
  595.       CASE ER_COMMENT;     WriteF('Manque "*/"\n')
  596.       CASE ER_SOURCEMEM;   WriteF('Pas de mémoire pour le source !\n')
  597.       CASE ER_INFILE;      WriteF('Ne peut ouvrir le fichier "\s".\n',name)
  598.       CASE ER_EXPIDENT;    WriteF('Manque l''identificateur\n')
  599.       CASE ER_ARGS;        WriteF('Nombre illégal d''arguments\n')
  600.       CASE ER_TYPE;        WriteF('Mauvais type de variable/expression\n')
  601.       CASE ER_EXPLBRACKET; WriteF('Manque le crochet gauche [\n')
  602.       CASE ER_STACK;       WriteF('Limite du dépacement mémoire : \d récusions\n',rec)
  603.       CASE ER_ALLOC;       WriteF('N''a put faire une allocation dynamique !\n')
  604.       CASE ER_ARRAY;       WriteF('Index de tableau hors norme\n')
  605.       CASE ER_FILE;        WriteF('Erreur de fichier\n')
  606.       CASE ER_GFXWIN;      WriteF('N''est pas une fenêtre-utilisateur pour les graphiques\n')
  607.       CASE ER_VALUES;      WriteF('Valeur(s) illégale(s)\n')
  608.     ENDSELECT
  609.     IF erpos<>NIL
  610.       StrCopy(erstr,erpos,ALL)
  611.       FOR a:=0 TO ERLEN-1 DO IF erstr[a]=10 THEN erstr[a]:=32
  612.       WriteF('NEARBY: \s\n',erstr)
  613.     ENDIF
  614.   ELSEIF nr=-1
  615.     WriteF('*** Programme terminé.\n')
  616.   ENDIF
  617.   IF conout<>NIL THEN WriteF('Pressez <return> pour continuer...\n')
  618.   CleanUp(0)
  619. ENDPROC
  620.  
  621. keywords:
  622. CHAR 'write...', 'add.....', 'eq......', 'uneq....', 'sub.....',
  623.      'mul.....', 'div.....', 'and.....', 'or......', 'not.....',
  624.      'if......', 'do......', 'select..', 'set.....', 'for.....',
  625.      'while...', 'until...', 'defun...', 'lambda..', 'apply...',
  626.      'readint.', 'array...', 'greater.', 'smaller.', 'locate..',
  627.      'cls.....', 'dump....', 'window..', 'tell....', 'told....',
  628.      'see.....', 'seen....', 'string..', 'read....', 'get.....',
  629.      'put.....', 'filelen.', 'line....', 'plot....', 'box.....',
  630.      'mousex..', 'mousey..', 'mouse...', 'text....'
  631.